Celestin Apprentice 4/Apprentice-Release4.iso/Source Code/Libraries/PNL Libraries/MyListWindow.p

Text File | 1995-09-18 | 20.2 KB | 810 lines | [TEXT/CWIE]

unit MyListWindow;

interface

    uses
        Lists, MyOOMainLoop;

    type
        ListWindowObject = object(DObject)
                list: ListHandle;
                hcontrol: ControlHandle;
                list_offset, list_width, max_display_width, header_height: integer;
                typed_chars: str31;
                typed_time: longInt;
                procedure CreateList (font, size: integer; ldefID: integer; hscroll: boolean);
                procedure Destroy;
                override;
                procedure DoItemWhere (er: eventRecord; item: integer);
                override;
                procedure Resize;
                override;
                procedure DrawGrow;
                override;
                procedure DoActivateDeactivate (activate: boolean);
                override;
                procedure DoKey (modifiers: integer; ch: char; code: integer);
                override;
                procedure SelectAll (on: boolean);
                function Match (c: cell; var what: str255): boolean;
                procedure Find (what: str255; fromstart, allatonce, backwards: boolean);
                procedure AdjustHContol (canRedraw: BOOLEAN);
                procedure SetListWidth (max: integer);
                function DontDrag (er: EventRecord): boolean;
                function DoLClick (er: EventRecord): boolean;
                procedure DoDoubleClick;
                procedure DoDoubleClickCell (c: cell);
                function GetEntryName (c: cell): str255;
                function GetUniqueEntryName (c: cell): str255;
                procedure OpenParent;
                procedure LDEF (message: integer; select: boolean; var r: Rect; c: Cell; dataOffset, dataLen: integer);
                procedure DrawHeader (r: rect);
                procedure DoHeaderClick (r: rect; where: Point; modifiers: integer);
                procedure SetSingleSelection (v: integer);
                function SelectFirstAfter (s: str255): boolean;
                function SelectFirstBefore (s: str255): boolean;
                function GetFirstSelection (var c: Cell): boolean;
                function GetLastSelection (var c: Cell): boolean;
                function CountSelections: integer;
                function IsSelection: boolean;
                function DoSetupDragCell (c: cell; dragref: DragReference; dragrgn: RgnHandle): OSErr;
                function DoSetupDrag (dragref: DragReference; dragrgn: RgnHandle): OSErr;
                override;
            end;

    procedure InitMyListWindow;

implementation

    uses
        ToolUtils, Drag,
        MyDialogs, MyAssertions, MyTypes, MyMathUtils, MySystemGlobals, MyListManager, MyCursors, MyCallProc;

    const
        list_item = 1;

    var
        gDrawListProc : UniversalProcPtr;
        gCallLDEFProc : UniversalProcPtr;
        gMyClickLoopProc : UniversalProcPtr;
        gHActionProc : UniversalProcPtr;

    procedure DrawList (dp: dialogPtr; item: integer);
        var
            r, rh: rect;
            obj: ListWindowObject;
    begin
        SetPort(dp);
        obj := ListWindowObject(GetWObject(dp));
        PenNormal;
        GetDItemRect(dp, item, r);
        rh := r;
        r.top := r.top + obj.header_height + 1;
        InsetRect(r, -1, -1);
        FrameRect(r);
        if obj.header_height > 0 then begin
            rh.bottom := rh.top + obj.header_height;
            obj.DrawHeader(rh);
        end;
        obj.DrawGrow;
        LUpdate(dp^.visRgn, obj.list);
    end;

    procedure ListWindowObject.SelectAll (on: boolean);
        var
            i: integer;
            c: cell;
    begin
        for i := 0 to list^^.databounds.bottom - 1 do begin
            c.h := 0;
            c.v := i;
            LSetSelect(on, c, list);
        end;
    end;

    function ListWindowObject.Match (c: cell; var what: str255): boolean;
    begin
        c:=c; { UNUSED! }
        what:=what; { UNUSED! }
        Match := false;
    end;

    procedure ListWindowObject.Find (what: str255; fromstart, allatonce, backwards: boolean);
        var
            c: cell;
            found, found1: boolean;
    begin
        if allatonce then begin
            found := false;
            c.v := 0;
            c.h := 0;
            while (c.v < list^^.databounds.bottom) do begin
                found1 := Match(c, what);
                LSetSelect(found1, c, list);
                if found1 then begin
                    found := true;
                end;
                c.v := c.v + 1;
            end;
        end
        else begin
            if backwards then begin
                if fromstart then begin
                    c.v := list^^.databounds.bottom-1;
                    c.h := 0;
                end else begin
                    c.v := 0;
                    c.h := 0;
                    if LGetSelect(true, c, list) then begin
                        c.v:=c.v-1;
                    end else begin
                        c.v := list^^.databounds.bottom-1;
                        c.h := 0;
                    end;
                end;
                found := false;
                while (c.v >=0) do begin
                    found := Match(c, what);
                    if found then begin
                        leave;
                    end;
                    c.v := c.v - 1;
                end;
            end else begin
                c.v := 0;
                c.h := 0;
                if not fromstart then begin
                    while LGetSelect(true, c, list) do begin
                        c.v := c.v + 1;
                        c.h := 0;
                    end;
                end;
                found := false;
                while (c.v < list^^.databounds.bottom) do begin
                    found := Match(c, what);
                    if found then begin
                        leave;
                    end;
                    c.v := c.v + 1;
                end;
            end;
            if found then begin
                SetSingleSelection(c.v);
            end;
        end;
        if not found then begin
            SysBeep(1);
        end;
    end;

    procedure ListWindowObject.LDEF (message: integer; select: boolean; var r: Rect; c: Cell; dataOffset, dataLen: integer);
    begin
        message:=message; { UNUSED! }
        select:=select; { UNUSED! }
        r:=r; { UNUSED! }
        c:=c; { UNUSED! }
        dataOffset:=dataOffset; { UNUSED! }
        dataLen:=dataLen; { UNUSED! }
    end;

    procedure ListWindowObject.DrawHeader (r: rect);
    begin
        r:=r; { UNUSED! }
    end;

    procedure ListWindowObject.DoHeaderClick (r: rect; where: Point; modifiers: integer);
    begin
        r:=r; { UNUSED! }
        where:=where; { UNUSED! }
        modifiers:=modifiers; { UNUSED! }
    end;

    procedure CallLDEF (message: integer; select: boolean; var r: Rect; c: Cell; dataOffset, dataLen: integer; lh: ListHandle);
        var
            obj:WObject; { BUG IN MWP }
    begin
        obj:=GetWObject(lh^^.port);
        ListWindowObject(obj).LDEF(message, select, r, c, dataOffset, dataLen);
    end;

    procedure ListWindowObject.SetListWidth (max: integer);
    begin
        list_width := max;
        zoomSize.h := max + 16;
        zoomSize.v := list^^.cellSize.v * (list^^.dataBounds.bottom) + 16 + header_height;
        AdjustHContol(true);
    end;

    procedure ListWindowObject.AdjustHContol (canRedraw: BOOLEAN);
{Calculate the new control maximum value and current value }
{max is calculated by comparing the maximum document}
{width to the width of the viewRect. The current values are set by comparing the offset between}
{the view and destination rects. If necessary and we canRedraw, have the control be re-drawn by}
{calling ShowControl.}
        var
            max: INTEGER;
            oldValue, oldMax: INTEGER;
            cliprgn: RgnHandle;
            r: rect;
    begin
        oldValue := GetControlValue(hcontrol);
        oldMax := GetControlMaximum(hcontrol);
        GetDItemRect(window, list_item, r);
        max := list_width - (r.right - 16 - r.left);
        if max < 0 then begin
            max := 0;            {check for negative values}
        end;
        list_offset := Pin(0, oldValue, max);
        SetPort(window);
        clipRgn := NewRgn;
        GetClip(clipRgn);
        SetRect(r, 0, 0, 0, 0);
        ClipRect(r);
        SetControlMaximum(hcontrol, max);
        SetClip(clipRgn);
        DisposeRgn(clipRgn);
        SetControlValue(hcontrol, list_offset);
        if canRedraw and ((max <> oldMax) or (list_offset <> oldValue)) then begin
            ShowControl(hcontrol);            {check to see if the control can be re-drawn}
        end;
    end;

    procedure ListWindowObject.CreateList (font, size: integer; ldefID: integer; hscroll: boolean);
        var
            view, bounds: rect;
            siz: point;
            k: integer;
            h: handle;
            fi: FontInfo;
            dr: rect;
    begin
        handle_shift_tab := false;
        typed_time := 0;
        max_display_width := maxInt;
        header_height := 0;
        SetPort(window);
        TextFont(font);
        TextSize(size);
        GetFontInfo(fi);
        draw_grow_icon := true;
        GetDialogItem(window, list_item, k, h, view);
        SetDialogItem(window, list_item, k, handle(gDrawListProc), view);
        SetRect(bounds, 0, 0, 1, 0);
        view.right := view.right - 15;
        SetPt(siz, 30000, fi.ascent + fi.descent + fi.leading);
        list := LNew(view, bounds, siz, ldefID, window, true, true, false, true);
        list^^.refcon := longInt(gCallLDEFProc);
        if hscroll then begin
            SetRect(dr, 0, 0, 100, 16);
            hcontrol := NewControl(window, dr, '', true, 0, 0, 0, scrollBarProc, 0);
        end
        else begin
            hcontrol := nil;
        end;
        Resize;
    end;

    procedure ListWindowObject.Destroy;
    begin
        LDispose(list);
        inherited Destroy;
    end;

    procedure ListWindowObject.DoDoubleClickCell (c: cell);
    begin
        c:=c; { UNUSED! }
    end;

    function ListWindowObject.DoSetupDragCell (c: cell; dragref: DragReference; dragrgn: RgnHandle): OSErr;
    begin
        c:=c; { UNUSED! }
        dragref:=dragref; { UNUSED! }
        dragrgn:=dragrgn; { UNUSED! }
        DoSetupDragCell := -1;
    end;

    function ListWindowObject.DoSetupDrag (dragref: DragReference; dragrgn: RgnHandle): OSErr;
        var
            c: Cell;
            err: OSErr;
    begin
        err := -23;
        c.h := 0;
        c.v := 0;
        while LGetSelect(true, c, list) do begin
            err := DoSetupDragCell(c, dragref, dragrgn);
            if err <> noErr then begin
                leave;
            end;
            c.v := c.v + 1;
            c.h := 0;
        end;
        DoSetupDrag := err;
    end;

    var
        CLFirstCall: boolean;
        CLFirstPt: Point;
        CLlist: ListHandle;
        CLer: EventRecord;
        CLwobj: WObject;

    function MyClickLoop: boolean;
        var
            r, cellRect: rect;
            cellClicked: Cell;
            curPt: Point;
            dummy: boolean;
            ret: boolean;
    begin
        ret := true;
        if CLFirstCall then begin
            CLFirstCall := false;
            GetMouse(CLFirstPt);
        end else begin
            SetRect(r, CLfirstPt.h - 3, CLfirstPt.v - 3, CLfirstPt.h + 3, CLfirstPt.v + 3);
            cellClicked := LLastClick(CLlist);
            LRect(cellRect, cellClicked, CLlist);
            dummy := SectRect(r, cellRect, r);
            GetMouse(curPt);
            if not PtInRect(curPt, r) then begin
{ DebugStr('MyClickLoop Drag;g'); }
                CLwobj.DoTrackDrag(CLer);
                ret := false;
            end;
        end;
        MyClickLoop := ret;
    end;

    function ListWindowObject.DontDrag (er: EventRecord): boolean;
    begin
        er:=er; { UNUSED! }
        DontDrag := last_event_had_shift or last_event_had_command;
    end;

    function ListWindowObject.DoLClick (er: EventRecord): boolean;
        var
            double: boolean;
            savedcl: ProcPtr;
            local: Point;
    begin
        local := er.where;
        GlobalToLocal(local);
{ DebugStr('ListWindowObject.DontDrag;g'); }
        if not has_DragManager or DontDrag(er) then begin
{ DebugStr('ListWindowObject.DontDrag NOT!;g'); }
            CursorSetProcessing(false);
            double := LClickSafe(local, er.modifiers, list);
        end
        else begin
{ DebugStr('ListWindowObject.DontDrag YES!;g'); }
            savedcl := list^^.lClickLoop;
            list^^.lClickLoop := gMyClickLoopProc;
            CLFirstCall := true;
            CLlist := list;
            CLer := er;
            CLwobj := self;
            CursorSetProcessing(false);
            double := LClickSafe(local, er.modifiers, list);
            list^^.lClickLoop := savedcl;
        end;
        DoLClick := double;
    end;

    procedure ListWindowObject.OpenParent;
    begin
    end;

    procedure ListWindowObject.SetSingleSelection (v: integer);
    begin
        LSetSingleSelection(list, v);
        LAutoScroll(list);
    end;

    procedure ListWindowObject.DoDoubleClick;
        var
            c: Cell;
    begin
        c.h := 0;
        c.v := 0;
        while LGetSelect(true, c, list) do begin
            DoDoubleClickCell(c);
            c.v := c.v + 1;
            c.h := 0;
        end;
    end;

    var
        action_listobj: ListWindowObject;

    procedure CommonAction (control: ControlHandle; var amount: integer);
        var
            value, max, ovalue: integer;
    begin
        value := GetControlValue(control);
        ovalue := value;
        max := GetControlMaximum(control);
        value := Pin(0, value - amount, max);
        if value <> ovalue then begin
            SetControlValue(control, value);
        end;
        amount := ovalue - value;   { calculate true change }
    end; { CommonAction  }

{ Determines how much to change the value of the horizontal scrollbar by and how }
{ much to scroll the TE record. }
    procedure HAction (control: ControlHandle; part: integer);
        var
            amount: integer;
            window: WindowPtr;
    begin
        if (part <> 0) then begin
            window := action_listobj.window;
            case part of
                kControlUpButtonPart, kControlDownButtonPart:    begin    { a few pixels }
                    amount := 8;
                end;
                kControlPageUpPart, kControlPageDownPart: begin        { a page width }
                    with action_listobj.list^^.rView do begin
                        amount := (right - left);
                    end;
                end;
            end;
            if ((part = kControlDownButtonPart) or (part = kControlPageDownPart)) then begin
                amount := -amount;        { reverse direction }
            end;
            CommonAction(control, amount);
            if amount <> 0 then begin
                action_listobj.list_offset := GetControlValue(control);
                DrawList(window, list_item);
            end;
        end;
    end;

    function ListWindowObject.GetEntryName (c: cell): str255;
    begin
        c:=c; { UNUSED! }
        GetEntryName := '';
    end;

    function ListWindowObject.GetUniqueEntryName (c: cell): str255;
    begin
        GetUniqueEntryName := concat(GetEntryName(c), chr(0), chr(c.v div 256), chr(c.v mod 256));
    end;

    function ListWindowObject.SelectFirstAfter (s: str255): boolean;
        var
            i, index: integer;
            c: Cell;
            best, n: str255;
            good: boolean;
    begin
        good := false;
        best := concat(chr(255), chr(255));
        for i := 0 to list^^.databounds.bottom - 1 do begin
            c.h := 0;
            c.v := i;
            n := GetUniqueEntryName(c);
            if (IUCompString(s, n) < 0) & (IUCompString(n, best) < 0) then begin
                best := n;
                index := c.v;
                good := true;
            end;
        end;
        if good then begin
            SetSingleSelection(index);
        end;
        SelectFirstAfter := good;
    end;

    function ListWindowObject.SelectFirstBefore (s: str255): boolean;
        var
            i, index: integer;
            c: Cell;
            best, n: str255;
            good: boolean;
    begin
        good := false;
        index := 0;
        best := '';
        for i := 0 to list^^.databounds.bottom - 1 do begin
            c.h := 0;
            c.v := i;
            n := GetUniqueEntryName(c);
            if (IUCompString(s, n) > 0) & (IUCompString(n, best) > 0) then begin
                best := n;
                index := c.v;
                good := true;
            end;
        end;
        if good then begin
            SetSingleSelection(index);
        end;
        SelectFirstBefore := good;
    end;

    function ListWindowObject.GetFirstSelection (var c: Cell): boolean;
        var
            best, n: str255;
            index: integer;
    begin
        GetFirstSelection := false;
        c.h := 0;
        c.v := 0;
        best := concat(chr(255), chr(255));
        while LGetSelect(true, c, list) do begin
            GetFirstSelection := true;
            n := GetUniqueEntryName(c);
            if IUCompString(n, best) < 0 then begin
                index := c.v;
            end;
            c.v := c.v + 1;
        end;
        c.h := 0;
        c.v := index;
    end;

    function ListWindowObject.GetLastSelection (var c: Cell): boolean;
        var
            best, n: str255;
            index: integer;
    begin
        GetLastSelection := false;
        c.h := 0;
        c.v := 0;
        best := '';
        while LGetSelect(true, c, list) do begin
            GetLastSelection := true;
            n := GetUniqueEntryName(c);
            if IUCompString(n, best) > 0 then begin
                index := c.v;
            end;
            c.v := c.v + 1;
        end;
        c.h := 0;
        c.v := index;
    end;

    procedure ListWindowObject.DoKey (modifiers: integer; ch: char; code: integer);
        var
            c: Cell;
            index: integer;
            dummy: boolean;
            onlyoneselection: boolean;
    begin
        modifiers:=modifiers; { UNUSED! }
        code:=code; { UNUSED! }
        onlyoneselection := BAND(list^^.selFlags, lOnlyOne) <> 0;
        if ch < ' ' then begin
            typed_time := 0;
        end;
        case ord(ch) of
            downArrowChar:  begin
                if last_event_had_command then begin
                    DoDoubleClick;
                end
                else begin
                    if list^^.dataBounds.bottom > 0 then begin
                        if LGetLastSelection(list, c) then begin
                            index := c.v + 1;
                        end
                        else begin
                            index := 0;
                        end;
                        if index >= list^^.dataBounds.bottom then begin
                            index := list^^.dataBounds.bottom - 1;
                        end;
                        if onlyoneselection or not last_event_had_shift then begin
                            SetSingleSelection(index);
                        end
                        else begin
                            c.v := index;
                            LSetSelect(true, c, list);
                        end;
                    end;
                end;
            end;
            upArrowChar:  begin
                if last_event_had_command then begin
                    OpenParent;
                end
                else begin
                    if list^^.dataBounds.bottom > 0 then begin
                        if not LGetFirstSelection(list, c) then begin
                            c.v := list^^.dataBounds.bottom;
                        end;
                        c.v := c.v - 1;
                        if c.v < 0 then begin
                            c.v := 0;
                        end;
                        if onlyoneselection or not last_event_had_shift then begin
                            SetSingleSelection(c.v);
                        end
                        else begin
                            LSetSelect(true, c, list);
                        end;
                    end;
                end;
            end;
            homeChar:  begin
                LScroll(0, -list^^.dataBounds.bottom, list);
            end;
            endChar:  begin
                LScroll(0, list^^.dataBounds.bottom, list);
            end;
            pageUpChar:  begin
                LScroll(0, -(list^^.visible.bottom - list^^.visible.top - 2), list);
            end;
            pageDownChar:  begin
                LScroll(0, (list^^.visible.bottom - list^^.visible.top - 2), list);
            end;
            tabChar:  begin
                if last_event_had_shift then begin
                    if not GetFirstSelection(c) | not SelectFirstBefore(GetUniqueEntryName(c)) then begin
                        dummy := SelectFirstBefore(chr(255));
                    end;
                end
                else begin
                    if not GetLastSelection(c) | not SelectFirstAfter(GetUniqueEntryName(c)) then begin
                        dummy := SelectFirstAfter('');
                    end;
                end;
            end;
            3, 13:  begin
                DoDoubleClick;
            end;
            otherwise begin
                if ch >= ' ' then begin
                    if last_event_time - typed_time > 60 then begin
                        typed_chars := '';
                    end;
                    typed_time := last_event_time;
                    typed_chars := concat(typed_chars, ch);
                    if not SelectFirstAfter(typed_chars) then begin
                        dummy := SelectFirstBefore(chr(255));
                    end;
                end;
            end;
        end;
{ WARNING: self may have been destroyed! }
    end;

    procedure ListWindowObject.DoItemWhere (er: eventRecord; item: integer);
        var
            didit: boolean;
            ctl: ControlHandle;
            part, value: integer;
            r: rect;
            local: Point;
    begin
        case item of
            list_item:  begin
                SetPort(window);
                local := er.where;
                GlobalToLocal(local);
                if local.v < header_height then begin
                    GetDItemRect(window, list_item, r);
                    r.bottom := r.top + header_height;
                    DoHeaderClick(r, local, er.modifiers);
                end
                else begin
                    didit := false;
                    if hcontrol <> nil then begin
                        part := FindControl(local, window, ctl);
                        if ctl = hcontrol then begin
                            didit := true;
                            if part = kControlIndicatorPart then begin
                                value := GetControlValue(hcontrol);
                                part := TrackControl(hcontrol, local, nil);
                                if part <> 0 then begin
                                    list_offset := GetControlValue(hcontrol);
                                    if value <> list_offset then begin
                                        InvalRect(window^.portRect);
                                    end;
                                end;
                            end
                            else begin
                                action_listobj := self;
                                value := TrackControl(hcontrol, local, gHActionProc);
                            end;

                        end;
                    end;
                    if not didit & DoLClick(er) then begin
                        DoDoubleClick;
                    end;
                end;
            end;
            otherwise
                inherited DoItemWhere(er, item);
        end;
    end;

    procedure ListWindowObject.DoActivateDeactivate (activate: boolean);
    begin
        LActivate(activate, list);
        if hcontrol <> nil then begin
            if activate then begin
                ShowControl(hcontrol);
            end
            else begin
                HideControl(hcontrol);
            end;
        end;
        inherited DoActivateDeactivate(activate);
    end;

    procedure ListWindowObject.Resize;
        const
            invis = 0;
            vis = 255;
        var
            r: rect;
            width, height, nheight, lineheight: integer;
    begin
        SetPort(window);
        lineheight := list^^.cellSize.v;
        width := window^.portrect.right - window^.portrect.left;
        height := window^.portrect.bottom - window^.portrect.top;
        nheight := (height - header_height - 16) mod lineheight;
        if nheight <> 0 then begin
            SizeWindow(window, width, height - nheight, false);
        end;
        growRect.top := (50 + lineheight - 1) div lineheight * lineheight + header_height + 16;
        r.left := 0;
        r.right := window^.portrect.right + 1;
        if r.right > max_display_width then begin
            r.right := max_display_width;
        end;
        r.top := 0;
        r.bottom := window^.portrect.bottom;
        SetDItemRect(window, list_item, r);
        r.top := r.top + header_height + 1;
        r.bottom := r.bottom - 15;
        height := r.bottom - r.top;
        list^^.rView.topleft := r.topleft; { LMove???? }
        LSize(r.right - r.left - 16, height, list);
        if hcontrol <> nil then begin
            hcontrol^^.contrlVis := invis;
            MoveControl(hcontrol, r.left, r.bottom);
            SizeControl(hcontrol, r.right - r.left - 15, 16);
            AdjustHContol(false);
            hcontrol^^.contrlVis := vis;
        end;
        zoomSize.v := list^^.cellSize.v * (list^^.dataBounds.bottom) + 16 + header_height;
        InvalRect(window^.portRect);
        inherited Resize;
    end;

    procedure ListWindowObject.DrawGrow;
        var
            r: rect;
    begin
        SetRect(r, -30000, header_height + 1, 30000, 30000);
        DrawTheFriggingGrowIcon(window, r);
    end;

    function ListWindowObject.CountSelections: integer;
    begin
        CountSelections := LCountSelections(list);
    end;

    function ListWindowObject.IsSelection: boolean;
    begin
        IsSelection := LHasSelection(list);
    end;

    procedure InitMyListWindow;
    begin
        gDrawListProc := NewUserItemProc(@DrawList);
        gCallLDEFProc := NewListDefProc(@CallLDEF);
        gMyClickLoopProc := NewProc(@MyClickLoop, uppListClickLoopProcInfo);
        gHActionProc := NewControlActionProc(@HAction);
    end;

end.
    function MyClickLoop: boolean; { returns the bloody equal flag for gods sake! }
    begin
        MyClickLoop := MyClickLoop2; { BE VERY CAREFUL!  Returns the equal flag! }
    end;